home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / mislib.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  3.4 KB  |  104 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;; This file is IMPLEMENTATION-DEPENDENT.
  21.  
  22.  
  23. (in-package 'lisp)
  24.  
  25.  
  26. (export 'time)
  27. (export '(decode-universal-time encode-universal-time))
  28.  
  29.  
  30. (in-package 'system)
  31.  
  32.  
  33. (proclaim '(optimize (safety 2) (space 3)))
  34.  
  35.  
  36. (defmacro time (form)
  37.   `(let (real-start real-end run-start run-end x)
  38.      (setq real-start (get-internal-real-time))
  39.      (setq run-start (get-internal-run-time))
  40.      (setq x (multiple-value-list ,form))
  41.      (setq run-end (get-internal-run-time))
  42.      (setq real-end (get-internal-real-time))
  43.      (fresh-line *trace-output*)
  44.      (format *trace-output*
  45.              "real time : ~,3F secs~%~
  46.               run time  : ~,3F secs~%"
  47.              (/ (- real-end real-start) internal-time-units-per-second)
  48.              (/ (- run-end run-start) internal-time-units-per-second))
  49.      (values-list x)))
  50.  
  51.  
  52. (defconstant month-days-list '(31 28 31 30 31 30 31 31 30 31 30 31))
  53. (defconstant seconds-per-day #.(* 24 3600))
  54.  
  55. (defun leap-year-p (y)
  56.   (and (zerop (mod y 4))
  57.        (or (not (zerop (mod y 100))) (zerop (mod y 400)))))
  58.  
  59. (defun number-of-days-from-1900 (y)
  60.   (let ((y1 (1- y)))
  61.     (+ (* (- y 1900) 365)
  62.        (floor y1 4) (- (floor y1 100)) (floor y1 400)
  63.        -460)))
  64.  
  65. (defun decode-universal-time (ut &optional (tz *default-time-zone*))
  66.   (let (sec min h d m y dow)
  67.     (decf ut (* tz 3600))
  68.     (multiple-value-setq (d ut) (floor ut seconds-per-day))
  69.     (setq dow (mod d 7))
  70.     (multiple-value-setq (h ut) (floor ut 3600))
  71.     (multiple-value-setq (min sec) (floor ut 60))
  72.     (setq y (+ 1900 (floor d 366)))  ; Guess!
  73.     (do ((x))
  74.         ((< (setq x (- d (number-of-days-from-1900 y)))
  75.             (if (leap-year-p y) 366 365))
  76.          (setq d (1+ x)))
  77.       (incf y))
  78.     (when (leap-year-p y)
  79.           (when (= d 60)
  80.                 (return-from decode-universal-time
  81.                              (values sec min h 29 2 y dow nil tz)))
  82.           (when (> d 60) (decf d)))
  83.     (do ((l month-days-list (cdr l)))
  84.         ((<= d (car l)) (setq m (- 13 (length l))))
  85.       (decf d (car l)))
  86.     (values sec min h d m y dow nil tz)))
  87.  
  88. (defun encode-universal-time (sec min h d m y
  89.                               &optional (tz *default-time-zone*))
  90.   (incf h tz)
  91.   (when (<= 0 y 99)
  92.         (multiple-value-bind (sec min h d m y1 dow dstp tz)
  93.             (get-decoded-time)
  94.           (declare (ignore sec min h d m dow dstp tz))
  95.           (incf y (- y1 (mod y1 100)))
  96.           (cond ((< (- y y1) -50) (incf y 100))
  97.                 ((>= (- y y1) 50) (decf y 100)))))
  98.   (unless (and (leap-year-p y) (> m 2)) (decf d 1))
  99.   (+ (* (apply #'+ d (number-of-days-from-1900 y)
  100.                (butlast month-days-list (- 13 m)))
  101.         seconds-per-day)
  102.      (* h 3600) (* min 60) sec))
  103.  
  104.